MacTech 1 to 12/MacTech-vol-1-12.toast/Source/MacTech® Magazine/Volume 03 - 1987/03.12 Dec 87/Tear off Menus example/tml version/TearMenu.Pas

Pascal/Delphi Source File | 1987-08-31 | 20.1 KB | 757 lines | [TEXT/EDIT]

{###############################################################################}
{#                                           #}
{#    Tear Menu - By Darryl Lovato of TML Systems, Inc.               #}
{#                                           #}
{###############################################################################}

program TearMenu;

uses MacIntf;

{###############################################################################}
{#                                           #}
{#                linker Directives Follow                   #}
{#                                           #}
{###############################################################################}

{$T APPL TEAR}
{$B+}
{$L TearMenuRes}

{###############################################################################}
{#                                           #}
{#                Global Contants Follow                   #}
{#                                           #}
{###############################################################################}

const
  AppleMenuID = 1;
  FileMenuID = 2;
  EditMenuID = 3;
  graphicalMenu = 4;
  WindResID = 1;
  AboutID = 3000;

{###############################################################################}
{#                                           #}
{#               Global Variables Follow                   #}
{#                                           #}
{###############################################################################}

var
  myMenus : Array[AppleMenuID..EditMenuID] of MenuHandle;
  Done : Boolean;
  RegWDEFWindow : WindowPtr;
  GrowArea : rect;
  DragArea : rect;
  myWindowPeek : WindowPeek;
  MyGraphicsMenu : menuhandle;
  currentPatWind : WindowPtr;

{###############################################################################}
{#                                           #}
{#                MyWindowDef function                   #}
{#                                           #}
{###############################################################################}

function MyWindowDef(varCode : Integer;
            theWindow : WindowPtr;
            message : Integer;
            param : LongInt)
            : LongInt;
type
  RectPtr = ^Rect;

var
  aRectPtr : RectPtr;
  myWindowPeek : WindowPeek;

procedure DoDrawMessage(WindToDraw : WindowPtr;
              DrawParam : LongInt);
var
  TitleBarRect : Rect;
  CurrentY : Integer;
  index : Integer;
  GoAwayBox : Rect;

begin
  if WindowPeek(WindToDraw)^.visible then
    begin

      TitleBarRect := WindowPeek(WindToDraw)^.strucRgn^^.rgnBBox;

      if DrawParam <> 0 then {just toggle goAway box}
        begin
      with TitleBarRect do
        begin
          top := top + 3;
          left := left + 5;
          bottom := top + 8;
          right := left + 8;
        end;
      InsetRect(TitleBarRect,1,1);
      InvertRect(TitleBarRect);
    end
      else {we need to draw the window frame}
        begin
      PenNormal;

      FrameRect(TitleBarRect);

      TitleBarRect.bottom := TitleBarRect.top + 13;

      FrameRect(TitleBarRect);
      InsetRect(TitleBarRect,1,1); {shrink by 1}
      EraseRect(TitleBarRect);

      if WindowPeek(WindToDraw)^.hilited then
        begin { add hiliting }
          FillRect(TitleBarRect,black);
          with TitleBarRect do
            begin
              top := top + 2;
              left := left + 4;
              bottom := top + 8;
              right := left + 8;
            end;
          PenMode(patXor);
          FrameRect(TitleBarRect);
          PenNormal;
        end;
    end;
    end;
end;

function DoHitMessage(WindToTest : WindowPtr;
            theParam : LongInt) : LongInt;
var
  globalPt : Point;
  aRect : Rect;
  GoAwayBox : Rect;
  tempRect : Rect;
begin
  globalPt.h := LoWord(theParam);
  globalPt.v := HiWord(theParam);
  aRect := WindowPeek(WindToTest)^.strucRgn^^.rgnBBox;
  aRect.bottom := aRect.top + 12; {create tBar Rect}
  tempRect := WindowPeek(WindToTest)^.strucRgn^^.rgnBBox;
  if PtInRect(globalPt,tempRect) then {in structure rgn?}
    begin
      tempRect := WindowPeek(WindToTest)^.contRgn^^.rgnBBox;
      if PtInRect(globalPt,tempRect) then {if it was in content rgn}
        DoHitMessage := wInContent
      else if PtInRect(globalPt,aRect) then {in the drag or go-away}
        begin
      if WindowPeek(WindToTest)^.hilited then
        begin {we need to check the go-away box}
          with aRect do
            begin
              top := top + 2;
              left := left + 4;
              bottom := top + 8;
              right := left + 8;
            end;
          if PtInRect(globalPt,aRect) then
            DoHitMessage := wInGoAway
          else
            DoHitMessage := wInDrag;
        end
      else
        DoHitMessage := wInDrag;
    end
      else {it was in our window frame}
        DoHitMessage := wNoHit;
    end
  else {it wasn't in our window at all}
    DoHitMessage := wNoHit;
end;

procedure DoCalcRgnsMessage(WindToCalc : WindowPtr);
var
  tempRect : Rect;
  aWindowPeek : WindowPeek;
  aRgn : RgnHandle;
begin
  tempRect := WindToCalc^.PortRect;

  OffsetRect(tempRect, -WindToCalc^.PortBits.Bounds.Left,
                -WindToCalc^.PortBits.Bounds.Top);

  dec(TempRect.top);
  RectRgn(WindowPeek(WindToCalc)^.contRgn,tempRect);

  InsetRect(tempRect,-1,-1);
  tempRect.top := tempRect.top - 12;
  RectRgn(WindowPeek(WindToCalc)^.strucRgn,tempRect);
end;

begin
  MyWindowDef := 0;
  case message of
    wDraw : DoDrawMessage(theWindow, param);
    wHit : MyWindowDef := DoHitMessage(theWindow,param);
    wCalcRgns : DoCalcRgnsMessage(theWindow);
    wNew : ;
    wDispose : ;
    wGrow : ;
  end;
end;

{###############################################################################}
{#                                           #}
{#        function GetItemRect(item : integer) : rect;               #}
{#                                           #}
{###############################################################################}

function GetItemRect(item : integer) : rect;
  var
    tempRect : Rect;
  begin
    with tempRect do
      begin
        top := (((item - 1) div 8) * 16) - 1;
        bottom := top + 17;
        left := (((item - 1) mod 8) * 16) - 1;
        right := left + 17;
      end;
    GetItemRect := tempRect;
  end;

{###############################################################################}
{#                                           #}
{#            procedure DrawPatWindow;                          #}
{#                                           #}
{###############################################################################}

procedure DrawPatWindow;
  var
    i : integer;
    currentPat : Pattern;
    currRect : Rect;
  begin
    for i := 1 to 96 do
      begin
        currRect := GetItemRect(i);
        FrameRect(currRect);
    GetIndPattern(currentPat,100,i);
    FillRect(currRect,currentPat);
    FrameRect(currRect);
      end;
  end;

{###############################################################################}
{#                                           #}
{#    function GetMItemRect(whichRect : Integer; myRect : Rect) : Rect;      #}
{#                                           #}
{###############################################################################}

function GetMItemRect(whichRect : Integer; myRect : Rect) : Rect;
  var
    ItemRect : Rect;
  begin
    ItemRect := GetItemRect(whichRect);
    OffSetRect(itemRect, myRect.left, myRect.top);
    GetMItemRect := ItemRect;
  end;

{###############################################################################}
{#                                           #}
{#         procedure drawItem(myRect : rect; myItem : integer);           #}
{#                                           #}
{###############################################################################}

 procedure drawItem(myRect : rect; myItem : integer);
   var
     currentPat : pattern;
   begin
     if (myItem > 0) and (myItem < 97) then
       begin
         myRect := GetMItemRect(myItem,myRect);
         GetIndPattern(currentPat,100,myItem);
         FillRect(myRect,currentPat);
         FrameRect(myRect);
       end;
   end;

{###############################################################################}
{#                                           #}
{#        procedure clearitem(myRect : Rect; lastCell : integer);           #}
{#                                           #}
{###############################################################################}

procedure clearitem(myRect : Rect; lastCell : integer);
  begin
    DrawItem(myRect,lastCell - 9);
    DrawItem(myRect,lastCell - 8);
    DrawItem(myRect,lastCell - 7);
    DrawItem(myRect,lastCell - 1);
    DrawItem(myRect,lastCell);
    DrawItem(myRect,lastCell + 1);
    DrawItem(myRect,lastCell + 7);
    DrawItem(myRect,lastCell + 8);
    DrawItem(myRect,lastCell + 9);
  end;

{###############################################################################}
{#                                           #}
{#            Menu Definition Routine                       #}
{#                                           #}
{###############################################################################}

procedure MyMenuDef(message : Integer;
        theMenu : MenuHandle;
        var menuRect : Rect;
        hitPt : Point;
        var whichItem : Integer);

  procedure DoDrawMessage(myMenu : MenuHandle;
              myRect : Rect);
    const
      MBarHeight = 20;
    var
      whichRect : Integer;
      currentPat : Pattern;
      currRect : Rect;
    begin
      for whichRect := 1 to 96 do
    Drawitem(myRect,whichRect);
    end;

  function DoChooseMessage(myMenu : MenuHandle;
              myRect : Rect;
            myPoint : Point;
            oldItem : Integer) : Integer;
    var
      currRect : Rect;
      alldone : boolean;
      whichRect : Integer;
      oldRect : Rect;
      mPt : Point;
      lastPt : Point;
      lastRect : Rect;
      menuPt : Point;
      tempRect : Rect;
      exitrect : rect;
      saveClip : RgnHandle;
      io : integer;
    begin
      ClipRect(myRect);
      whichRect := 1;
      alldone := false;
      repeat
        currRect := GetMItemRect(whichRect,myRect);
    if PtInRect(myPoint,currRect) then
      alldone := true
    else
      inc(whichRect);
      until ((AllDone) or (whichRect > 96));
      if AllDone then { if we are in a item}
        begin
      if (whichRect <> oldItem) then
        begin
          if (oldItem <> 0) then
        ClearItem(myRect,oldItem);
          InsetRect(currRect,-6,-6);
          PenSize(6,6);
          PenPat(white);
          FrameRect(currRect);
          PenNormal;
          InsetRect(currRect,-1,-1);
          FrameRect(currRect);
       end;
       DoChooseMessage := whichRect;
    end
      else { we are not in a item}
        begin
      if oldItem <> 0 then { invert the old item}
        clearitem(myRect,oldItem);
      DoChooseMessage := 0;

      PenMode(notPatXOR);
      penpat(gray);
      exitrect := myrect;
      InsetRect(ExitRect,-10,-10);
      ExitRect.top := 20;
      menuPt.h := myRect.left + ((myRect.right - myRect.left) div 2);
          menuPt.v := myRect.top + ((myRect.bottom - myRect.top) div 2);
      SetRect(tempRect,0,0,0,0);
      lastRect := tempRect;
      ClipRect(screenbits.bounds);
      repeat
        GetMouse(mPt);
        LocalToGlobal(mPt);
        if ((Longint(mpt) <> Longint(lastPt)) and
           (not PtInRect(mpt,ExitRect)) and (mPt.v > 20)) then
          begin
            lastPt := mPt;
            tempRect := myRect;
            OffSetRect(tempRect, mPt.h - menuPt.h, mPt.v - menuPt.v);
            if tempRect.top < 20 then
              begin
                tempRect.top := 20;
            tempRect.bottom := 20 + 202;
              end;
        FrameRect(lastRect);
        FrameRect(tempRect);
        lastRect := tempRect;
          end;
      until (not button) or ptInRect(mPt, exitrect) or (mPt.v < 21);
      FrameRect(lastRect);
      PenNormal;
      if (not PtInRect(mpt,ExitRect)) and (mPt.v > 20) then
        begin
          lastrect.top := lastrect.top + 12;
          io := PostEvent(12,Longint(lastRect.topleft));
          { this communicates back to the main event}
          { loop that a window was just torn from the}
          { menu.  We pass the new topLeft in the message}
        end;
    end;
    end;

  procedure DoSizeMessage(var myMenu : MenuHandle);
    begin
      with myMenu^^ do
        begin
          menuWidth := 127;
          menuHeight := 191;
        end;
    end;

begin
  case message of
    mSizeMsg : DoSizeMessage(theMenu);
    mDrawMsg : DoDrawMessage(theMenu,menuRect);
    mChooseMsg : whichItem := DoChooseMessage(theMenu,menuRect,hitPt,whichItem);
  end;
end;

{###############################################################################}
{#                                           #}
{#                 ShowAbout procedure                   #}
{#                                           #}
{###############################################################################}

procedure ShowAbout;
var
  theDlog : DialogPtr;
  theItem : Integer;
begin
  theDlog := GetNewDialog(AboutID,nil,Pointer(-1));
  ModalDialog(nil,theItem);
  DisposDialog(theDlog);
end;

{###############################################################################}
{#                                           #}
{#                ProcessMenu procedure                   #}
{#                                           #}
{###############################################################################}

procedure ProcessMenu(codeWord : Longint);
type
  PatPtr = ^Pattern;
var
  menuNum : Integer;
  itemNum : Integer;
  NameHolder : str255;
  dummy : Integer;
  yuck : boolean;
  myPattern : Pattern;
  DeskPatternPtr : PatPtr;
  savePort,aPort : grafPtr;
  theRgn1,theRgn2 : RgnHandle;
begin
  if codeWord <> 0 then
    begin
      menuNum := HiWord(codeWord);
      itemNum := LoWord(codeWord);
      case menuNum of { the different menus}
        AppleMenuID :
      if itemNum < 3 then
        ShowAbout
      else
        begin
          GetItem(myMenus[AppleMenuID],itemNum,NameHolder);
          dummy := OpenDeskAcc(NameHolder);
        end;
    FileMenuID : Done := true;
    EditMenuID :yuck := SystemEdit(itemNum - 1);
    GraphicalMenu :
      if ItemNum <> 0 then
        begin
          GetIndPattern(myPattern,100,ItemNum);
          SetPort(currentPatWind);
          BackPat(myPattern);
          EraseRect(currentPatWind^.portRect);
        end;
      end;
      HiliteMenu(0);
    end;
end;

{###############################################################################}
{#                                           #}
{#            Deal With Mouse Downs procedure                   #}
{#                                           #}
{###############################################################################}

procedure DealWithMouseDowns(theEvent: EventRecord);
var
  location : Integer;
  windowPointedTo : WindowPtr;
  mouseLoc : point;
  windowLoc : integer;
  VandH : Longint;
  Height : Integer;
  Width : Integer;
  currRect,myRect : Rect;
  newcell,LastCell : integer;
  thePt, LastPt : Point;
  i : integer;
  myPattern : Pattern;
begin
  mouseLoc := theEvent.where;
  windowLoc := FindWindow(mouseLoc,windowPointedTo);
  case windowLoc of
    inMenuBar :
      ProcessMenu(MenuSelect(mouseLoc));
    inSysWindow :
      SystemClick(theEvent,windowPointedTo);
    inContent :
      if windowPointedTo <> FrontWindow then
    SelectWindow(windowPointedTo)
      else
    begin
      if RegWDEFWindow = windowPointedTo then
        begin
          SetPort(RegWDEFWindow);
          GetMouse(lastPt);
          newCell := 0;
          lastCell := 0;
              myRect := RegWDEFWindow^.portRect;
          while waitmouseup do {track mouse in pattern wind}
            begin
              GetMouse(thePt);
              if not PtInRect(thePt,myRect) then
                begin {we moved outside the window}
                  if lastCell <> 0 then
                    clearItem(myRect,lastCell);
                  lastCell := 0;
                end
              else
                begin
                  for i := 1 to 96 do
                    if PtInRect(thePt,GetItemRect(i)) then
                      newCell := i;
                  if newCell <> lastCell then
                    begin
                      if (lastCell <> 0) then
                    Clearitem(myRect,lastCell);
                      currRect := GetItemRect(newCell);
                      InsetRect(currRect,-6,-6);
                      PenSize(6,6);
                      PenPat(white);
                      FrameRect(currRect);
                      PenNormal;
                      InsetRect(currRect,-1,-1);
                      FrameRect(currRect);
                      lastCell := newCell;
                    end;
                end;
            end;
          Clearitem(myRect,lastCell);
          GetIndPattern(myPattern,100,newCell);
          SetPort(currentPatWind);
          BackPat(myPattern);
          EraseRect(currentPatWind^.portRect);
        end;
    end;
    inDrag :
      begin
        DragWindow(windowPointedTo,mouseLoc,DragArea);
    SelectWindow(windowPointedTo);
      end;
    inGoAway :
      if TrackGoAway(windowPointedTo,mouseLoc) then
    HideWindow(windowPointedTo);
  end;
end;

{###############################################################################}
{#                                           #}
{#            Deal With Key Downs procedure                   #}
{#                                           #}
{###############################################################################}

procedure DealWithKeyDowns(theEvent: EventRecord);
type
  Trick = packed record
    case boolean of
      true : (long : Longint);
      false : (chr3,chr2,chr1,chr0 : char)
    end;
var
  CharCode : char;
  TrickVar : Trick;
begin
  TrickVar.long := theEvent.message;
  CharCode := TrickVar.chr0;
  if BitAnd(theEvent.modifiers,CmdKey) = CmdKey then {check for a menu selection}
    ProcessMenu(MenuKey(CharCode))
end;

{###############################################################################}
{#                                           #}
{#            Deal With Updates procedure                   #}
{#                                           #}
{###############################################################################}

procedure DealWithUpdates(theEvent: EventRecord);
var
  UpDateWindow : WindowPtr;
  tempPort : WindowPtr;

begin
  UpDateWindow := WindowPtr(theEvent.message);
  GetPort(tempPort);
    SetPort(UpDateWindow);
    BeginUpDate(UpDateWindow);
      EraseRect(UpDateWindow^.portRect);
      if UpdateWindow <> currentPatWind then
        DrawPatWindow;
    EndUpDate(UpDateWindow);
  SetPort(tempPort);
end;

{###############################################################################}
{#                                           #}
{#            MainEventLoop procedure                       #}
{#                                           #}
{###############################################################################}

procedure MainEventLoop;
var
  Event : EventRecord;
  ProcessIt : boolean;
begin
  repeat
    SystemTask;
    if GetNextEvent(everyEvent, Event) then
      case Event.what of
    mouseDown : DealWithMouseDowns(Event);
    AutoKey : DealWithKeyDowns(Event);
    KeyDown : DealWithKeyDowns(Event);
    UpdateEvt : DealWithUpdates(Event);
    12 :begin { we return this when a window has been torn}
          HideWindow(RegWDefWindow);
          MoveWindow(RegWDefWindow,Point(Event.message).h,
              Point(Event.message).v,true);
          ShowWindow(RegWDEFWindow);
        end;
      end;
  until Done;
end;

{###############################################################################}
{#                                           #}
{#                 SetupMemory procedure                   #}
{#                                           #}
{###############################################################################}

procedure SetupMemory;
var
  x : Longint;
begin
  x := ORD4(ApplicZone) + 128000;
  SetApplLimit(Pointer(x));
  MaxApplZone;
  MoreMasters;
  MoreMasters;
  MoreMasters;
end;

{###############################################################################}
{#                                           #}
{#                 SetupLimits                       #}
{#                                           #}
{###############################################################################}

procedure SetupLimits;
var
  Screen : Rect;
begin
  Screen := ScreenBits.bounds;
  with Screen do
    begin
      SetRect(DragArea,left+4,top+24,right-4,bottom-4);
      SetRect(GrowArea,left,top+24,right,bottom);
    end;
end;

{###############################################################################}
{#                                           #}
{#                MakeMenus procedure                   #}
{#                                           #}
{###############################################################################}

procedure MakeMenus;
var
  index : Integer;
begin
  for index := AppleMenuID to EditMenuID do
    begin
      myMenus[index] := GetMenu(index);
      InsertMenu(myMenus[index],0);
    end;
  AddResMenu(myMenus[AppleMenuID],'DRVR');

  MyGraphicsMenu := NewMenu(4,'Graphics');

  MyGraphicsMenu^^.menuProc := NewHandle(0);
  MyGraphicsMenu^^.menuProc^ := Ptr(@MyMenuDef);
  CalcMenuSize(MyGraphicsMenu);

  Insertmenu(MyGraphicsMenu,0);

  DrawMenuBar;
end;

{###############################################################################}
{#                                           #}
{#            Program Excecution Starts Here                   #}
{#                                           #}
{###############################################################################}

begin
  Done := false;
  FlushEvents(everyEvent,0);

  InitGraf(@thePort);
  InitFonts;
  InitWindows;
  InitMenus;
  TEInit;
  InitDialogs(nil);
  InitCursor;

  SetupLimits;
  SetupMemory;
  MakeMenus;

  RegWDEFWindow := GetNewWindow(WindResID,nil,Pointer(-1));
  myWindowPeek := WindowPeek(RegWDEFWindow);

  myWindowPeek^.windowDefProc := NewHandle(0);
  myWindowPeek^.windowDefProc^ := Ptr(@MyWindowDef);

  SetWRefCon(RegWDEFWIndow,Ord4(MyGraphicsMenu));

  currentPatWind := GetNewWindow(2,nil,pointer(-1));
  SetPort(currentPatWind);
  BackPat(gray);
  EraseRect(currentPatWind^.portRect);

  MainEventLoop;
end. {thats all folkes!}